perm filename PLTCMD.OLD[MSS,LCS]1 blob
sn#107284 filedate 1974-06-15 generic text, type T, neo UTF8
C**** PLTCMD, FILLER, NNN, UNPACK, ROFF ********
SUBROUTINE PLTCMD
CC IMPLICIT INTEGER(A-Q,S-Z)
COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
DIMENSION NMS(8),RMOV1(8),RMOV2(8)
COMMON /DL/X22,SAVER,NAME /ALF/INP(3),ML
COMMON RJB,JE,CENTR,JB,RJQ(20),JQ(20)
EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
1,(RJC,RJQ(1)),(I2,INP(2)),(RJH,RJQ(6)),(I3,INP(3))
F78F(1)='(78F)'
FA5(1)='(A5) '
FA1(1)='(A1) '
IF(I2.NE.'X')GO TO 1
CC ML=' '
I2=0
RXC=0
RMOV1(1)='Y'
NAME=0
14 KA=0
3 KA=KA+1
CC IF(ML.EQ.' ')GO TO 15
IF(ML.EQ.0)GO TO 15
K=K-2
ML=ML-1
IF(ML.EQ.0)GO TO 10
GO TO 31
15 TYPE 2,KA
ACCEPT 11,K,ML
C TYPE LAST NAME, NUMBER FOR A SERIES
50 IF(K.EQ.' ')GO TO 10
IF(K.EQ.'99')GO TO 140
C 99=BACKUP
31 IF(LOOKD(K))GO TO 56
C JUMP IF FILE FOUND
TYPE 55
GO TO 15
55 FORMAT(' FILE NOT FOUND'/)
11 FORMAT(A5,I)
56 NMS(KA)=K
CC IF(ML.EQ.' ')GO TO 5
IF(ML.EQ.0)GO TO 5
RJH='Y'
GO TO 21
5 TYPE 8
ACCEPT FA5,RJH
IF(RJH.EQ.'99')GO TO 15
IF(RJH.NE.'Y')RJH=0
IF(RJH.EQ.0)REREAD F78F,RJH
C MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
21 RMOV1(KA+1)=RJH
RMOV2(KA)=RJH
GO TO 3
140 KA=KA-1
GO TO 15
10 KB=KA-1
IF(I3.NE.'G')GO TO 22
RSIZ=1
GO TO 222
22 TYPE 9
ACCEPT F78F,RSIZ
IF(RSIZ.EQ.99.OR.RSIZ.EQ.0)GO TO 5
222 KA=0
1 IF(NAME.NE.0)GO TO 12
IF(KA.EQ.KB)CALL EXITB
C EXITB IS FOR FR80 RELEASE ****************
NAME=NMS(KA+1)
TYPE 111,NAME
RETURN
12 KA=KA+1
NAME=0
RJD=1
IF(INP(3).EQ.'C')RJD=0
C 'PXC' = CALCOMP OUTPUT
RJH=0
RJB=RSIZ
RJC=RSIZ
RJG=0
RJE=1
RJF=1
IF(RMOV2(KA).NE.'Y')RJG=RMOV2(KA)
IF(RMOV1(KA).NE.0)RJE=0
IF(RMOV2(KA).NE.0.OR.RJG.NE.0)RJF=0
2 FORMAT(' TYPE FILE NAME',I2,1X$)
8 FORMAT(' MOVE UP AT END? ',$)
9 FORMAT(' SIZE FACTOR? ',$)
111 FORMAT(1XA5/)
END
SUBROUTINE OLDFIL(IFILL,QJB,QCENT,BX,BY)
DIMENSION IFILL(1)
COMMON /DL/IXRX,SAVER,NAME
COMMON /SIZ/RSZ,JCEN,KCEN
COMMON /FL/IC,N,NQ,RZ,XGP
COMMON /STF/RSTFAC(8),RSTJC
COMMON /PLTR/IPLT,RHT,DIS
COMMON/DPY/IGO,RXGP,ITOP,IBOT
PX=1
IF(BX.EQ.0)BX=1
IF(BY.EQ.0)BY=1
IF(BX)PX=-1
IXGP=XGP
RSI=RSTJC*BY
C RI IS INVERSION FACTOR
BZ=BY/BX
RT=RSTJC*BX
C RS=HORIZ. RT=VERT.
JXGP=RXGP
NX=2
C NX IS POINTER IN X ARRAY
ID=IFILL(NX)
IF(IPLT)GO TO 101
RBZ=QJB*RSZ
RXX=RSZ*RT
C WHAT ABOUT RXX????????
RYX=QCENT*RSZ
RXY=RSI*RSZ
GO TO 100
101 RXX=RT*DIS
RXY=RSI*RHT
RBZ=QJB*DIS
RYX=QCENT*RHT
100 RM=-1000
IF(PX)RM=-RM
I=NX+1
103 CALL UNPACK(IA,IB,IFILL(I))
IF(IA.NE.IFILL(I+1)/10000)GO TO 102
I=I+1
GO TO 103
102 G=IA*RT+QJB
H=IB*RSI+QCENT
IF(IPLT)GO TO 200
CALL LINES(G,H,3)
GO TO 300
200 IF(IXRX.EQ.0)GO TO 90
M=ROFF(-H*RHT+RXGP)
N=ROFF(G*DIS+XGP)
GO TO 80
90 M=ROFF(G*DIS)
N=ROFF(H*RHT)
80 CALL PLOT(M,N,3)
300 NN=ID-1
C LAST OF ARRAY-1
P=IA*RXX
CALL UNPACK(IG,H,IFILL(I+1))
RB=IG*RXX+PX
J=1
1 JJ=1
IF(PX)GO TO 30
IF(RM.GT.RB)GO TO 13
GO TO 31
30 IF(RM.LT.RB)GO TO 13
31 IF(J)GO TO 2
3 CALL NNN(NN,1,0,IFILL)
C FINDS BOTTOM POINTER
GO TO 16
2 CALL NNN(I,0,1,IFILL)
C FINDS TOP POINTER(I)
16 CALL UNPACK(JAX,JB,IFILL(N))
CALL UNPACK(JG,JH,IFILL(N+1))
CALL UNPACK(IQ,H,IFILL(NQ))
RZ=RZ*RXX
10 RDIS=JAX-JG
IF(PX)GO TO 32
IF(P.GT.RZ)P=RZ
GO TO 33
32 IF(P.LT.RZ)P=RZ
C REVERSES VERT.
33 Q=IQ*RXX
C=IC*RXY+RYX
IF(RDIS.NE.0)GO TO 6
C FOR STRAIIGHT UP-DOWN LINES
IF(NN-1.EQ.I)GO TO 13
P=P-PX
GO TO 5
6 H=BZ*(JB-JH)/RDIS
11 HH=(P-Q)*H+C
PP=P+RBZ
IH=ROFF(HH)
IP=ROFF(PP)
C ROFF IS FOR ROUND-OFF ERRORS
IF(IP.EQ.MP.AND.IH.EQ.MH)GO TO 180
MP=IP
MH=IH
C OMITS REPEATED POINTS
IF(IPLT)GO TO 17
CC IF(RSZ.LE.0.8571)GO TO 34
CC IP=IP-JCEN
CC IH=IH-KCEN
CC34 CALL AVECT(IP,IH)
CALL LINES(PP/RSZ,HH/RSZ,2)
GO TO 180
17 IF(IXRX.EQ.0)GO TO 19
K=IP
IP=-IH+JXGP
C NO RNDOFF OR DIS-RHT FACTORS HERE YET.
IH=K+IXGP
19 CALL PLOT(IP,IH,2)
180 JJ=JJ-1
IF(JJ)GO TO 12
RM=P
P=P+PX
IF(PX)GO TO 35
IF(P.LT.RZ)GO TO 11
GO TO 5
35 IF(P.GT.RZ)GO TO 11
5 IF(J)GO TO 4
NN=NN-1
IF(I.GT.NN)GO TO 13
GO TO 3
4 I=I+1
IF(I.GT.NN)GO TO 13
402 CALL UNPACK(IA,IB,IFILL(I+1))
RB=IA*RXX+PX
GO TO 2
12 J=-J
GO TO 1
13 NX=ID+1
IF(ID.EQ.IFILL(1))GO TO 130
ID=IFILL(NX)
GO TO 100
130 MP=1000
MH=1000
RETURN
END
SUBROUTINE NNN(J,L,K,IFILL)
COMMON /FL/IC,N,NQ,RZ,XGP
DIMENSION IFILL(1)
CALL UNPACK(IZ,IC,IFILL(J+K))
CALL UNPACK(N,IC,IFILL(J+L))
N=J
C C IS THE CONSTANT
NQ=N+L
RZ=IZ
RETURN
END
SUBROUTINE UNPACK(M,N,I)
COMMON/LL/L
C L IS FOR VIS. OR INVIS. LINES.
N=I
L=2
M=N/100000000
IF(M.EQ.0)GO TO 2
L=3
N=N-100000000*M
2 M=N/10000
CC N=N-M*10000
N=MOD(N,10000)
IF(M.GT.1000)M=1000-M
IF(N.GT.1000)N=1000-N
END
FUNCTION ROFF(R)
S=.5
IF(R)S=-S
ROFF=R+S
END
C****** CHANGE 3, 4 AND 5 TO JFCL IN DDT WHEN USING DISTORTION.(SEE 'LINES')
SUBROUTINE FILLMS(L,IDAT,RJB,CENTR,RJF,RJG)
COMMON/DL/IXRX,SAVER,NAME
COMMON/DST/BB,CC/FLM/X(200),Y(200),NX(200)
DIMENSION IDAT(1)
COMMON/PLTR/IPLT,RHT,DIS/LL/LL/STF/RR(8),RSTJC
DATA MP/2/,MD/6/
C MD=DISPLAY MP=PLOTTER MX=XGP
DX=DIS
RX=RHT
D=RSTJC*RJF
R=RSTJC*RJG
4 GO TO 1
C=CC
B=BB
C SAVES IT. IT WILL RETURN LATER.
BB=B/DIS
CC=1000
1 KK=0
DO 205 J=1,L
CALL UNPACK(M,N,IDAT(J))
KK=KK+1
NX(KK)=0
IF(LL.EQ.3)NX(KK)=3
X(KK)=ROFF((RJB+D*M)*DIS)
Y(KK)=ROFF((CENTR+R*N)*RHT)
3 GO TO 205
Y(KK)=Y(KK)*(C-BB*(ABS(X(KK))))
C FOR DISTORTION
205 CONTINUE
NX(1)=KK
DIS=1.0
RHT=DIS
M=MD
IF(IPLT)M=MP-IXRX
C STOPS DISTORTION IN 'LINES'
2 CALL FILLER(X,Y,NX,M)
DIS=DX
RHT=RX
5 RETURN
C NEXT TO RESET DISTORTION FACT.
BB=B
CC=C
RETURN
END
SUBROUTINE ROTATE(I,L,DEG)
DIMENSION I(1)
N=I(L)
KNT=501
C ROTATED DATA IS PUT BACK STARTING AT LOCATION 501.
I(KNT)=N
DO 1 K=L+1,N+L-1
CALL UNPACK(J,M,I(K))
X=J
Y=M
JJ=I(K)/100000000
AX=ATAN2(X,Y)*57.29578
HYP=SQRT(X**2+Y**2)
ROT=DEG+AX
J=ROFF(HYP*COSD(ROT))
M=ROFF(HYP*SIND(ROT))
KNT=KNT+1
IF(J)J=1000-J
IF(M)M=1000-M
1 I(KNT)=M*10000+J+JJ*100000000
L=501
END